home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
376-400
/
disk_386
/
xlispstat
/
src1.lzh
/
XLisp
/
xljump.c
< prev
next >
Wrap
C/C++ Source or Header
|
1990-10-03
|
4KB
|
179 lines
/* xljump - execution context routines */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include "xlisp.h"
#include "osdef.h"
#ifdef ANSI
#include "xlproto.h"
#else
#include "xlfun.h"
#endif ANSI
#include "xlvar.h"
/* forward declarations */
#ifdef ANSI
void findandjump(int,char *);
#else
void findandjump();
#endif ANSI
/* xlbegin - beginning of an execution context */
void xlbegin(cptr,flags,expr)
CONTEXT *cptr; int flags; LVAL expr;
{
cptr->c_flags = flags;
cptr->c_expr = expr;
cptr->c_xlstack = xlstack;
cptr->c_xlenv = xlenv;
cptr->c_xlfenv = xlfenv;
cptr->c_xldenv = xldenv;
cptr->c_xlcontext = xlcontext;
cptr->c_xlargv = xlargv;
cptr->c_xlargc = xlargc;
cptr->c_xlfp = xlfp;
cptr->c_xlsp = xlsp;
xlcontext = cptr;
}
/* xlend - end of an execution context */
void xlend(cptr)
CONTEXT *cptr;
{
xlcontext = cptr->c_xlcontext;
}
/* xlgo - go to a label */
void xlgo(label)
LVAL label;
{
CONTEXT *cptr;
LVAL *argv;
int argc;
/* find a tagbody context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & CF_GO) {
argc = cptr->c_xlargc;
argv = cptr->c_xlargv;
while (--argc >= 0)
if (*argv++ == label) {
cptr->c_xlargc = argc;
cptr->c_xlargv = argv;
xljump(cptr,CF_GO,NIL);
}
}
xlfail("no target for GO");
}
/* xlreturn - return from a block */
void xlreturn(name,val)
LVAL name,val;
{
CONTEXT *cptr;
/* find a block context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
xljump(cptr,CF_RETURN,val);
xlfail("no target for RETURN");
}
/* xlthrow - throw to a catch */
void xlthrow(tag,val)
LVAL tag,val;
{
CONTEXT *cptr;
/* find a catch context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
xljump(cptr,CF_THROW,val);
xlfail("no target for THROW");
}
/* xlsignal - signal an error */
void xlsignal(emsg,arg)
char *emsg; LVAL arg;
{
CONTEXT *cptr;
/* find an error catcher */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & CF_ERROR) {
if (cptr->c_expr && emsg)
xlerrprint("error",NULL,emsg,arg);
xljump(cptr,CF_ERROR,NIL);
}
}
/* xltoplevel - go back to the top level */
void xltoplevel()
{
stdputstr("[ back to top level ]\n");
findandjump(CF_TOPLEVEL,"no top level");
}
/* xlbrklevel - go back to the previous break level */
void xlbrklevel()
{
findandjump(CF_BRKLEVEL,"no previous break level");
}
/* xlcleanup - clean-up after an error */
void xlcleanup()
{
stdputstr("[ back to previous break level ]\n");
findandjump(CF_CLEANUP,"not in a break loop");
}
/* xlcontinue - continue from an error */
void xlcontinue()
{
findandjump(CF_CONTINUE,"not in a break loop");
}
/* xljump - jump to a saved execution context */
void xljump(target,mask,val)
CONTEXT *target; int mask; LVAL val;
{
/* unwind the execution stack */
for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
/* check for an UNWIND-PROTECT */
if ((xlcontext->c_flags & CF_UNWIND)) {
xltarget = target;
xlmask = mask;
break;
}
/* restore the state */
xlstack = xlcontext->c_xlstack;
xlenv = xlcontext->c_xlenv;
xlfenv = xlcontext->c_xlfenv;
xlunbind(xlcontext->c_xldenv);
xlargv = xlcontext->c_xlargv;
xlargc = xlcontext->c_xlargc;
xlfp = xlcontext->c_xlfp;
xlsp = xlcontext->c_xlsp;
xlvalue = val;
/* call the handler */
longjmp(xlcontext->c_jmpbuf,mask);
}
/* findandjump - find a target context frame and jump to it */
LOCAL void findandjump(mask,error)
int mask; char *error;
{
CONTEXT *cptr;
/* find a block context */
for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
if (cptr->c_flags & mask)
xljump(cptr,mask,NIL);
xlabort(error);
}